home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Icon 8.1 / msm-1 / icont.sit / lcode.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-09-19  |  33.1 KB  |  1,328 lines  |  [TEXT/MPS ]
  1. /*
  2.  * lcode.c -- linker routines to parse .u1 files and produce icode.
  3.  */
  4.  
  5. #include "link.h"
  6. #include "tproto.h"
  7. #include "globals.h"
  8. #include "opcode.h"
  9. #include "::h:keyword.h"
  10. #include "::h:version.h"
  11. #include "::h:header.h"
  12.  
  13. /*
  14.  *  This needs fixing ...
  15.  */
  16. #undef CsetPtr
  17. #define CsetPtr(b,c)    ((c) + (((b)&0377) >> LogIntBits)) 
  18.  
  19. /*
  20.  * Prototypes.
  21.  */
  22.  
  23. hidden novalue    backpatch    Params((int lab));
  24. hidden novalue    clearlab    Params((noargs));
  25. hidden novalue    flushcode    Params((noargs));
  26. hidden novalue    intout        Params((int oint));
  27. hidden novalue    lemit        Params((int op,char *name));
  28. hidden novalue    lemitcon    Params((int k));
  29. hidden novalue    lemiteven    Params((noargs));
  30. hidden novalue    lemitin        Params((int op,word offset,int n,char *name));
  31. hidden novalue    lemitint    Params((int op,long i,char *name));
  32. hidden novalue    lemitl        Params((int op,int lab,char *name));
  33. hidden novalue    lemitn        Params((int op,word n,char *name));
  34. hidden novalue    lemitproc
  35.    Params((word name,int nargs,int ndyn,int nstat, int fstat));
  36. hidden novalue    lemitr        Params((int op,word loc,char *name));
  37. hidden novalue    outblock    Params((char *addr,int count));
  38. hidden novalue    wordout        Params((word oword));
  39.  
  40. #ifdef DeBugLinker
  41. hidden novalue    dumpblock    Params((char *addr,int count));
  42. #endif                    /* DeBugLinker */
  43.  
  44. #if AMIGA
  45. #include <fcntl.h>
  46. #endif                    /* AMIGA */
  47.  
  48. #if MVS
  49. extern char *routname;
  50. #endif                    /* MVS */
  51.  
  52. #ifndef MaxHeader
  53. #define MaxHeader MaxHdr
  54. #endif                    /* MaxHeader */
  55.  
  56. word pc = 0;        /* simulated program counter */
  57.  
  58. #define outword(n)    wordout((word)(n))
  59. #define outop(n)    intout((int)(n))
  60. #define CodeCheck(n) if ((long)codep + (n) > (long)((long)codeb + maxcode))\
  61.                      codeb = (char *) trealloc(codeb, &codep, &maxcode, 1,\
  62.                        (n), "code buffer");
  63.  
  64. /*
  65.  * gencode - read .u1 file, resolve variable references, and generate icode.
  66.  *  Basic process is to read each line in the file and take some action
  67.  *  as dictated by the opcode.    This action sometimes involves parsing
  68.  *  of arguments and usually culminates in the call of the appropriate
  69.  *  lemit* routine.
  70.  */
  71. novalue gencode()
  72.    {
  73.    register int op, k, lab;
  74.    int j, nargs, flags, implicit;
  75.    char *name;
  76.    word id, procname;
  77.    struct centry *cp;
  78.    struct gentry *gp;
  79.    struct fentry *fp;
  80.    union xval gg;
  81.  
  82.    while ((op = getopc(&name)) != EOF) {
  83.       switch (op) {
  84.  
  85.          /* Ternary operators. */
  86.  
  87.          case Op_Toby:
  88.          case Op_Sect:
  89.  
  90.          /* Binary operators. */
  91.  
  92.          case Op_Asgn:
  93.          case Op_Cat:
  94.          case Op_Diff:
  95.          case Op_Div:
  96.          case Op_Eqv:
  97.          case Op_Inter:
  98.          case Op_Lconcat:
  99.          case Op_Lexeq:
  100.          case Op_Lexge:
  101.          case Op_Lexgt:
  102.          case Op_Lexle:
  103.          case Op_Lexlt:
  104.          case Op_Lexne:
  105.          case Op_Minus:
  106.          case Op_Mod:
  107.          case Op_Mult:
  108.          case Op_Neqv:
  109.          case Op_Numeq:
  110.          case Op_Numge:
  111.          case Op_Numgt:
  112.          case Op_Numle:
  113.          case Op_Numlt:
  114.          case Op_Numne:
  115.          case Op_Plus:
  116.          case Op_Power:
  117.          case Op_Rasgn:
  118.          case Op_Rswap:
  119.          case Op_Subsc:
  120.          case Op_Swap:
  121.          case Op_Unions:
  122.  
  123.          /* Unary operators. */
  124.  
  125.          case Op_Bang:
  126.          case Op_Compl:
  127.          case Op_Neg:
  128.          case Op_Nonnull:
  129.          case Op_Null:
  130.          case Op_Number:
  131.          case Op_Random:
  132.          case Op_Refresh:
  133.          case Op_Size:
  134.          case Op_Tabmat:
  135.          case Op_Value:
  136.  
  137.          /* Instructions. */
  138.  
  139.          case Op_Bscan:
  140.          case Op_Ccase:
  141.          case Op_Coact:
  142.          case Op_Cofail:
  143.          case Op_Coret:
  144.          case Op_Dup:
  145.          case Op_Efail:
  146.          case Op_Eret:
  147.          case Op_Escan:
  148.          case Op_Esusp:
  149.          case Op_Limit:
  150.          case Op_Lsusp:
  151.          case Op_Pfail:
  152.          case Op_Pnull:
  153.          case Op_Pop:
  154.          case Op_Pret:
  155.          case Op_Psusp:
  156.          case Op_Push1:
  157.          case Op_Pushn1:
  158.          case Op_Sdup:
  159.             newline();
  160.             lemit(op, name);
  161.             break;
  162.  
  163.          case Op_Chfail:
  164.          case Op_Create:
  165.          case Op_Goto:
  166.          case Op_Init:
  167.             lab = getlab();
  168.             newline();
  169.             lemitl(op, lab, name);
  170.             break;
  171.  
  172.          case Op_Cset:
  173.          case Op_Real:
  174.             k = getdec();
  175.             newline();
  176.             lemitr(op, lctable[k].c_pc, name);
  177.             break;
  178.  
  179.          case Op_Field:
  180.             id = getid();
  181.             newline();
  182.             fp = flocate(id);
  183.             if (fp == NULL) {
  184.                lfatal(&lsspace[id], "invalid field name");
  185.                break;
  186.                }
  187.             lemitn(op, (word)(fp->f_fid-1), name);
  188.             break;
  189.  
  190. #ifdef Xver
  191. xver(lcode.1)
  192. #endif                    /* Xver */
  193.  
  194.          case Op_Int: {
  195.             long i;
  196.             k = getdec();
  197.             newline();
  198.             cp = &lctable[k];
  199.             /*
  200.              * Check to see if a large integers has been converted to a string.
  201.              *  If so, generate the code for +s.
  202.              */
  203.             if (cp->c_flag & F_StrLit) {
  204.                lemit(Op_Pnull,"pnull");
  205.                lemitin(Op_Str, cp->c_val.sval, cp->c_length, "str");
  206.                lemit(Op_Number,"number");
  207.                break;
  208.                }
  209.             i = (long)cp->c_val.ival;
  210.             lemitint(op, i, name);
  211.             break;
  212.             }
  213.  
  214. #ifdef Xver
  215. xver(lcode.2)
  216. #endif                    /* Xver */
  217.  
  218.          case Op_Invoke:
  219.             k = getdec();
  220.             newline();
  221.             if (k == -1)
  222.                lemit(Op_Apply,"apply");
  223.             else
  224.                lemitn(op, (word)k, name);
  225.             break;
  226.  
  227.          case Op_Keywd:
  228.             k = getdec();
  229.             newline();
  230.             switch (k) {
  231.                case K_FAIL:
  232.                   lemit(Op_Efail,"efail");
  233.                   break;
  234.                case K_NULL:
  235.                   lemit(Op_Pnull,"pnull");
  236.                   break;
  237.                default:
  238.                lemitn(op, (word)k, name);
  239.             }
  240.             break;
  241.  
  242.          case Op_Llist:
  243.             k = getdec();
  244.             newline();
  245.             lemitn(op, (word)k, name);
  246.             break;
  247.  
  248.          case Op_Lab:
  249.             lab = getlab();
  250.             newline();
  251.  
  252. #ifdef DeBugLinker
  253.             if (Dflag)
  254.                fprintf(dbgfile, "L%d:\n", lab);
  255. #endif                    /* DeBugLinker */
  256.             backpatch(lab);
  257.             break;
  258.  
  259.          case Op_Line:
  260.             if (lnfree >= &lntable[nsize])
  261.                lntable  = (struct ipc_line *)trealloc(lntable, &lnfree, &nsize,
  262.                   sizeof(struct ipc_line), 1, "line number table");
  263.             lnfree->ipc = pc;
  264.             lineno = getdec();
  265.             lnfree->line = lineno;
  266.             lnfree++;
  267.  
  268. #ifdef EventMon
  269.             lemitn(op, (word)lineno, name);
  270. #endif                    /* EventMon */
  271.             
  272.             newline();
  273.  
  274. #ifdef Xver
  275. xver(lcode.3)
  276. #endif                    /* Xver */
  277.  
  278. #ifdef LineCodes
  279. #ifndef EventMon
  280.             lemit(Op_Noop,"noop");
  281. #endif                    /* EventMon */
  282. #endif                    /* LineCodes */
  283.  
  284.             break;
  285.  
  286.          case Op_Colm:            /* always recognize, maybe ignore */
  287. #ifdef EventMon
  288.             colmno = getdec();
  289.             lemitn(op, (word)colmno, name);
  290. #else                    /* EventMon */
  291.             getdec ();
  292. #endif                    /* EventMon */
  293.             break;
  294.  
  295.          case Op_Mark:
  296.             lab = getlab();
  297.             newline();
  298.             lemitl(op, lab, name);
  299.             break;
  300.  
  301.          case Op_Mark0:
  302.             lemit(op, name);
  303.             break;
  304.  
  305.          case Op_Str:
  306.             k = getdec();
  307.             newline();
  308.             cp = &lctable[k];
  309.             lemitin(op, cp->c_val.sval, cp->c_length, name);
  310.             break;
  311.     
  312.          case Op_Tally:
  313.             k = getdec();
  314.             newline();
  315.             lemitn(op, (word)k, name);
  316.             break;
  317.  
  318.          case Op_Unmark:
  319.             lemit(Op_Unmark, name);
  320.             break;
  321.  
  322.          case Op_Var:
  323.             k = getdec();
  324.             newline();
  325.             flags = lltable[k].l_flag;
  326.             if (flags & F_Global)
  327.                lemitn(Op_Global, (word)(lltable[k].l_val.global->g_index),
  328.                   "global");
  329.             else if (flags & F_Static)
  330.                lemitn(Op_Static, (word)(lltable[k].l_val.staticid-1), "static");
  331.             else if (flags & F_Argument)
  332.                lemitn(Op_Arg, (word)(lltable[k].l_val.offset-1), "arg");
  333.             else
  334.                lemitn(Op_Local, (word)(lltable[k].l_val.offset-1), "local");
  335.             break;
  336.  
  337.          /* Declarations. */
  338.  
  339.          case Op_Proc:
  340.             procname = getid();
  341.             newline();
  342.             locinit();
  343.             clearlab();
  344.             lineno = 0;
  345.             gp = glocate(procname);
  346.             implicit = gp->g_flag & F_ImpError;
  347.             nargs = gp->g_nargs;
  348.             lemiteven();
  349.             break;
  350.  
  351.          case Op_Local:
  352.             k = getdec();
  353.             flags = getoct();
  354.             id = getid();
  355.             putlocal(k, id, flags, implicit, procname);
  356.             break;
  357.  
  358.          case Op_Con:
  359.             k = getdec();
  360.             flags = getoct();
  361.             if (flags & F_IntLit) {
  362.                {
  363.                long m;
  364.                word s_indx;
  365.  
  366.                j = getdec();        /* number of characters in integer */
  367.                m = getint(j,&s_indx);    /* convert if possible */
  368.                if (m < 0) {         /* negative indicates integer too big */
  369.                   gg.sval = s_indx;    /* convert to a string */
  370.                   putconst(k, F_StrLit, j, pc, &gg);
  371.                   }
  372.                else {            /* integers is small enough */
  373.                   gg.ival = m;
  374.                   putconst(k, flags, 0, pc, &gg);
  375.                   }
  376.                }
  377.                }
  378.             else if (flags & F_RealLit) {
  379.                gg.rval = getreal();
  380.                putconst(k, flags, 0, pc, &gg);
  381.                }
  382.             else if (flags & F_StrLit) {
  383.                j = getdec();
  384.                gg.sval = getstrlit(j);
  385.                putconst(k, flags, j, pc, &gg);
  386.                }
  387.             else if (flags & F_CsetLit) {
  388.                j = getdec();
  389.                gg.sval = getstrlit(j);
  390.                putconst(k, flags, j, pc, &gg);
  391.                }
  392.             else
  393.                fprintf(stderr, "gencode: illegal constant\n");
  394.             newline();
  395.             lemitcon(k);
  396.             break;
  397.  
  398.          case Op_Filen:
  399.             if (fnmfree >= &fnmtbl[fnmsize])
  400.                fnmtbl = (struct ipc_fname *) trealloc(fnmtbl, &fnmfree,
  401.                   &fnmsize, sizeof(struct ipc_fname), 1, "file name table");
  402.  
  403. #ifdef CRAY
  404.             fnmfree->ipc = pc/8;
  405. #else                    /* CRAY */
  406.             fnmfree->ipc = pc;
  407. #endif                    /* CRAY */
  408.  
  409.             fnmfree->fname = getrest();
  410.             fnmfree++;
  411.             newline();
  412.             break;
  413.  
  414.          case Op_Declend:
  415.             newline();
  416.             gp->g_pc = pc;
  417.             lemitproc(procname, nargs, dynoff, lstatics-static1, static1);
  418.             break;
  419.  
  420.          case Op_End:
  421.             newline();
  422.             flushcode();
  423.             break;
  424.  
  425.          default:
  426.             fprintf(stderr, "gencode: illegal opcode(%d): %s\n", op, name);
  427.             newline();
  428.          }
  429.       }
  430.    }
  431.  
  432. /*
  433.  *  lemit - emit opcode.
  434.  *  lemitl - emit opcode with reference to program label.
  435.  *    for a description of the chaining and backpatching for labels.
  436.  *  lemitn - emit opcode with integer argument.
  437.  *  lemitr - emit opcode with pc-relative reference.
  438.  *  lemitin - emit opcode with reference to identifier table & integer argument.
  439.  *  lemitint - emit word opcode with integer argument.
  440.  *  lemiteven - emit null bytes to bring pc to word boundary.
  441.  *  lemitcon - emit constant table entry.
  442.  *  lemitproc - emit procedure block.
  443.  *
  444.  * The lemit* routines call out* routines to effect the "outputting" of icode.
  445.  *  Note that the majority of the code for the lemit* routines is for debugging
  446.  *  purposes.
  447.  */
  448. static novalue lemit(op, name)
  449. int op;
  450. char *name;
  451.    {
  452.  
  453. #ifdef DeBugLinker
  454.    if (Dflag)
  455.       fprintf(dbgfile, "%ld:\t%d\t\t\t\t# %s\n", (long)pc, op, name);
  456. #else                    /* DeBugLinker */
  457. #if MACINTOSH && MPW
  458. /* #pragma unused(name)    */
  459. #endif                    /* MACINTOSH && MPW */
  460. #endif                    /* DeBugLinker */
  461.  
  462.    outop(op);
  463.    }
  464.  
  465. static novalue lemitl(op, lab, name)
  466. int op, lab;
  467. char *name;
  468.    {
  469.  
  470. #ifdef DeBugLinker
  471.    if (Dflag)
  472.       fprintf(dbgfile, "%ld:\t%d\tL%d\t\t\t# %s\n", (long)pc, op, lab, name);
  473. #else                    /* DeBugLinker */
  474. #if MACINTOSH && MPW
  475. /* #pragma unused(name)    */
  476. #endif                    /* MACINTOSH && MPW */
  477. #endif                    /* DeBugLinker */
  478.  
  479.    if (lab >= maxlabels)
  480.       labels  = (word *) trealloc(labels, NULL, &maxlabels, sizeof(word), 
  481.          lab - maxlabels + 1, "labels");
  482.    outop(op);
  483.    if (labels[lab] <= 0) {        /* forward reference */
  484.       outword(labels[lab]);
  485.       labels[lab] = WordSize - pc;    /* add to front of reference chain */
  486.       }
  487.    else                    /* output relative offset */
  488.  
  489. #ifdef CRAY
  490.       outword((labels[lab] - (pc + WordSize))/8);
  491. #else                    /* CRAY */
  492.       outword(labels[lab] - (pc + WordSize));
  493. #endif                    /* CRAY */
  494.    }
  495.  
  496. static novalue lemitn(op, n, name)
  497. int op;
  498. word n;
  499. char *name;
  500.    {
  501.  
  502. #ifdef DeBugLinker
  503.    if (Dflag)
  504.       fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)n,
  505.          name);
  506. #else                    /* DeBugLinker */
  507. #if MACINTOSH && MPW
  508. /* #pragma unused(name) */
  509. #endif                    /* MACINTOSH && MPW */
  510. #endif                    /* DeBugLinker */
  511.  
  512.    outop(op);
  513.    outword(n);
  514.    }
  515.  
  516. #ifdef Xver
  517. xver(lcode.4)
  518. #endif                    /* Xver */
  519.  
  520. static novalue lemitr(op, loc, name)
  521. int op;
  522. word loc;
  523. char *name;
  524.    {
  525.  
  526. #ifdef CRAY
  527.    loc = (loc - pc - 16)/8;
  528. #else                    /* CRAY */
  529.    loc -= pc + ((IntBits/ByteBits) + WordSize);
  530. #endif                    /* CRAY */
  531.  
  532. #ifdef DeBugLinker
  533.    if (Dflag) {
  534.       if (loc >= 0)
  535.          fprintf(dbgfile, "%ld:\t%d\t*+%ld\t\t\t# %s\n",(long) pc, op,
  536.             (long)loc, name);
  537.       else
  538.          fprintf(dbgfile, "%ld:\t%d\t*-%ld\t\t\t# %s\n",(long) pc, op,
  539.             (long)-loc, name);
  540.       }
  541. #else                    /* DeBugLinker */
  542. #if MACINTOSH && MPW
  543. /* #pragma unused(name) */
  544. #endif                    /* MACINTOSH && MPW */
  545. #endif                    /* DeBugLinker */
  546.  
  547.    outop(op);
  548.    outword(loc);
  549.    }
  550.  
  551. static novalue lemitin(op, offset, n, name)
  552. int op, n;
  553. word offset;
  554. char *name;
  555.    {
  556.  
  557. #ifdef DeBugLinker
  558.    if (Dflag)
  559.       fprintf(dbgfile, "%ld:\t%d\t%d,S+%ld\t\t\t# %s\n", (long)pc, op, n,
  560.          (long)offset, name);
  561. #else                    /* DeBugLinker */
  562. #if MACINTOSH && MPW
  563. /* #pragma unused(name) */
  564. #endif                    /* MACINTOSH && MPW */
  565. #endif                    /* DeBugLinker */
  566.  
  567.    outop(op);
  568.    outword(n);
  569.    outword(offset);
  570.    }
  571.  
  572. /*
  573.  * lemitint can have some pitfalls.  outword is used to output the
  574.  *  integer and this is picked up in the interpreter as the second
  575.  *  word of a short integer.  The integer value output must be
  576.  *  the same size as what the interpreter expects.  See op_int and op_intx
  577.  *  in interp.s
  578.  */
  579. static novalue lemitint(op, i, name)
  580. int op;
  581. long i;
  582. char *name;
  583.    {
  584.  
  585. #ifdef DeBugLinker
  586.    if (Dflag)
  587.       fprintf(dbgfile,"%ld:\t%d\t%ld\t\t\t# %s\n",(long)pc,op,(long)i,name);
  588. #else                    /* DeBugLinker */
  589. #if MACINTOSH && MPW
  590. /* #pragma unused(name) */
  591. #endif                    /* MACINTOSH && MPW */
  592. #endif                    /* DeBugLinker */
  593.  
  594.    outop(op);
  595.    outword(i);
  596.    }
  597.  
  598. static novalue lemiteven()
  599.    {
  600.    word x = 0;
  601.    register int len;
  602.  
  603.    if (len = pc % (IntBits/ByteBits))
  604.       outblock((char *)x, (IntBits/ByteBits) - len);
  605.    }
  606.  
  607. static novalue lemitcon(k)
  608. register int k;
  609.    {
  610.    register int i, j;
  611.    register char *s;
  612.    int csbuf[CsetSize];
  613.    union {
  614.       char ovly[1];  /* Array used to overlay l and f on a bytewise basis. */
  615.       long l;
  616.       double f;
  617.       } x;
  618.  
  619.    if (lctable[k].c_flag & F_RealLit) {
  620.  
  621. #ifdef Double
  622. /* access real values one word at a time */
  623.       {  int *rp, *rq;
  624.          rp = (int *) &(x.f);
  625.          rq = (int *) &(lctable[k].c_val.rval);
  626.          *rp++ = *rq++;
  627.          *rp    = *rq;
  628.       }
  629. #else                    /* Double */
  630.       x.f = lctable[k].c_val.rval;
  631. #endif                    /* Double */
  632.  
  633. #ifdef DeBugLinker
  634.       if (Dflag) {
  635.          fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Real);
  636.          dumpblock(x.ovly,sizeof(double));
  637.          fprintf(dbgfile, "\t\t\t( %g )\n",x.f);
  638.          }
  639. #endif                    /* DeBugLinker */
  640.  
  641.       outword(T_Real);
  642.  
  643. #ifdef Double
  644. /* fill out real block with an empty word */
  645.       outword(0);
  646. #endif                    /* Double */
  647.  
  648.       outblock(x.ovly,sizeof(double));
  649.       }
  650.    else if (lctable[k].c_flag & F_CsetLit) {
  651.       for (i = 0; i < CsetSize; i++)
  652.          csbuf[i] = 0;
  653.       s = &lsspace[lctable[k].c_val.sval];
  654.       i = lctable[k].c_length;
  655.       while (i--) {
  656.          Setb(ToAscii(*s), csbuf);
  657.          s++;
  658.          }
  659.       j = 0;
  660.       for (i = 0; i < 256; i++) {
  661.          if (Testb(i, csbuf))
  662.            j++;
  663.          }
  664.  
  665. #ifdef DeBugLinker
  666.       if (Dflag) {
  667.          fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Cset);
  668.          fprintf(dbgfile, "\t%d\n",j);
  669.          }
  670. #endif                    /* DeBugLinker */
  671.  
  672.       outword(T_Cset);
  673.       outword(j);           /* cset size */
  674.       outblock((char *)csbuf,sizeof(csbuf));
  675.  
  676. #ifdef DeBugLinker
  677.       if (Dflag)
  678.          dumpblock((char *)csbuf,CsetSize);
  679. #endif                    /* DeBugLinker */
  680.  
  681.       }
  682.    }
  683.  
  684. static novalue lemitproc(name, nargs, ndyn, nstat, fstat)
  685. word name;
  686. int nargs, ndyn, nstat, fstat;
  687.    {
  688.    register int i;
  689.    register char *p;
  690.    word s_indx;
  691.    int size;
  692.    /*
  693.     * FncBlockSize = sizeof(BasicFncBlock) +
  694.     *  sizeof(descrip)*(# of args + # of dynamics + # of statics).
  695.     */
  696. #ifdef MultiThread
  697.    size = (10*WordSize) + (2*WordSize) * (abs(nargs)+ndyn+nstat);
  698. #else                    /* MultiThread */
  699.    size = (9*WordSize) + (2*WordSize) * (abs(nargs)+ndyn+nstat);
  700. #endif                    /* MultiThread */
  701.  
  702.    p = &lsspace[name];
  703. #ifdef DeBugLinker
  704.    if (Dflag) {
  705.       fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Proc); /* type code */
  706.       fprintf(dbgfile, "\t%d\n", size);            /* size of block */
  707.       fprintf(dbgfile, "\tZ+%ld\n",(long)(pc+size));    /* entry point */
  708.       fprintf(dbgfile, "\t%d\n", nargs);        /* # arguments */
  709.       fprintf(dbgfile, "\t%d\n", ndyn);            /* # dynamic locals */
  710.       fprintf(dbgfile, "\t%d\n", nstat);        /* # static locals */
  711.       fprintf(dbgfile, "\t%d\n", fstat);        /* first static */
  712.       fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n",    /* name of procedure */
  713.          (int)strlen(p), (long)(name), p);
  714.       }
  715. #endif                    /* DeBugLinker */
  716.  
  717.    outword(T_Proc);
  718.    outword(size);
  719.    outword(pc + size - 2*WordSize); /* Have to allow for the two words
  720.                      that we've already output. */
  721.    outword(nargs);
  722.    outword(ndyn);
  723.    outword(nstat);
  724.    outword(fstat);
  725. #ifdef MultiThread
  726.    outword(0);            /* program (filled in by interp) */
  727. #endif                /* MultiThread */
  728.    outword(strlen(p));          /* procedure name: length & offset */
  729.    outword(name);
  730.  
  731.    /*
  732.     * Output string descriptors for argument names by looping through
  733.     *  all locals, and picking out those with F_Argument set.
  734.     */
  735.    for (i = 0; i <= nlocal; i++) {
  736.       if (lltable[i].l_flag & F_Argument) {
  737.          s_indx = lltable[i].l_name;
  738.          p = &lsspace[s_indx];
  739.  
  740. #ifdef DeBugLinker
  741.          if (Dflag)
  742.             fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p),
  743.                (long)s_indx, p);
  744. #endif                    /* DeBugLinker */
  745.  
  746.          outword(strlen(p));
  747.          outword(s_indx);
  748.          }
  749.       }
  750.  
  751.    /*
  752.     * Output string descriptors for local variable names.
  753.     */
  754.    for (i = 0; i <= nlocal; i++) {
  755.       if (lltable[i].l_flag & F_Dynamic) {
  756.          s_indx = lltable[i].l_name;
  757.          p = &lsspace[s_indx];
  758.  
  759. #ifdef DeBugLinker
  760.          if (Dflag)
  761.             fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p),
  762.                (long)s_indx, p);
  763. #endif                    /* DeBugLinker */
  764.  
  765.          outword(strlen(p));
  766.          outword(s_indx);
  767.          }
  768.       }
  769.  
  770.    /*
  771.     * Output string descriptors for local variable names.
  772.     */
  773.    for (i = 0; i <= nlocal; i++) {
  774.       if (lltable[i].l_flag & F_Static) {
  775.          s_indx = lltable[i].l_name;
  776.          p = &lsspace[s_indx];
  777.  
  778. #ifdef DeBugLinker
  779.          if (Dflag)
  780.             fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p),
  781.                (long)s_indx, p);
  782. #endif                    /* DeBugLinker */
  783.  
  784.          outword(strlen(p));
  785.          outword(s_indx);
  786.          }
  787.       }
  788.    }
  789.  
  790. /*
  791.  * gentables - generate interpreter code for global, static,
  792.  *  identifier, and record tables, and built-in procedure blocks.
  793.  */
  794.  
  795. novalue gentables()
  796.    {
  797.    register int i;
  798.    register char *s;
  799.    register struct gentry *gp;
  800.    struct fentry *fp;
  801.    struct rentry *rp;
  802.    struct header hdr;
  803.  
  804. #if MVS
  805.    FILE *toutfile;        /* temporary file for icode output */
  806. #endif                    /* MVS */
  807.  
  808.    lemiteven();
  809.  
  810.    /*
  811.     * Output record constructor procedure blocks.
  812.     */
  813.    hdr.Records = pc;
  814.  
  815. #ifdef DeBugLinker
  816.    if (Dflag)
  817.       fprintf(dbgfile, "%ld:\t%d\t\t\t\t# record blocks\n",(long)pc, nrecords);
  818. #endif                    /* DeBugLinker */
  819.  
  820.    outword(nrecords);
  821.    for (gp = lgfirst; gp != NULL; gp = gp->g_next) {
  822.       if (gp->g_flag & (F_Record & ~F_Global)) {
  823.          s = &lsspace[gp->g_name];
  824.          gp->g_pc = pc;
  825.  
  826. #ifdef DeBugLinker
  827.          if (Dflag) {
  828.             fprintf(dbgfile, "%ld:\n", pc);
  829.             fprintf(dbgfile, "\t%d\n", T_Proc);
  830.             fprintf(dbgfile, "\t%d\n", RkBlkSize(gp));
  831.             fprintf(dbgfile, "\t_mkrec\n");
  832.             fprintf(dbgfile, "\t%d\n", gp->g_nargs);
  833.             fprintf(dbgfile, "\t-2\n");
  834.             fprintf(dbgfile, "\t%d\n", gp->g_procid);
  835.             fprintf(dbgfile, "\t1\n");
  836.             fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(s),
  837.                (long)gp->g_name, s);
  838.             }
  839.  
  840. #endif                    /* DeBugLinker */
  841.  
  842.          outword(T_Proc);        /* type code */
  843.      outword(RkBlkSize(gp));
  844.          outword(0);            /* entry point (filled in by interp)*/
  845.          outword(gp->g_nargs);        /* number of fields */
  846.          outword(-2);            /* record constructor indicator */
  847.          outword(gp->g_procid);        /* record id */
  848.          outword(1);            /* serial number */
  849. #ifdef MultiThread
  850.      outword(0);            /* program (filled in by interp) */
  851. #endif                    /* MultiThread */
  852.          outword(strlen(s));        /* name of record: size and offset */
  853.          outword(gp->g_name);
  854.  
  855.      for(i=0;i<gp->g_nargs;i++){    /* field names (filled in by interp) */
  856.         int foundit = 0;
  857.         /*
  858.          * Find the field field name corresponding to field i in
  859.          * record # gp->g_procid, then write out a descriptor for it.
  860.          */
  861.         for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) {
  862.            for(rp = fp->f_rlist; rp!= NULL; rp=rp->r_link) {
  863.           if(rp->r_recid == gp->g_procid && rp->r_fnum == i) {
  864.              if (foundit) {
  865.             /*
  866.              * This internal error should never occur
  867.              */
  868.             fprintf(stderr,"found rec %d field %d already!!\n",
  869.                 gp->g_procid, i);
  870.             fflush(stderr);
  871.             exit(1);
  872.             }
  873.              outword(strlen(&lsspace[fp->f_name]));
  874.              outword(fp->f_name);
  875.              foundit++;
  876.              }
  877.           }
  878.            }
  879.         if (!foundit) {
  880.            /*
  881.         * This internal error should never occur
  882.         */
  883.            fprintf(stderr,"never found rec %d field %d!!\n",
  884.                gp->g_procid,i);
  885.            fflush(stderr);
  886.            exit(1);
  887.            }
  888.         }
  889.          }
  890.       }
  891.  
  892.    /*
  893.     * Output record/field table.
  894.     */
  895.    hdr.Ftab = pc;
  896.  
  897. #ifdef DeBugLinker
  898.    if (Dflag)
  899.       fprintf(dbgfile, "%ld:\t\t\t\t\t# record/field table\n", (long)pc);
  900. #endif                    /* DeBugLinker */
  901.  
  902.    for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) {
  903.  
  904. #ifdef DeBugLinker
  905.       if (Dflag)
  906.          fprintf(dbgfile, "%ld:\n", (long)pc);
  907. #endif                    /* DeBugLinker */
  908.  
  909.       rp = fp->f_rlist;
  910.       for (i = 1; i <= nrecords; i++) {
  911.          if (rp != NULL && rp->r_recid == i) {
  912.  
  913. #ifdef DeBugLinker
  914.             if (Dflag)
  915.         fprintf(dbgfile, "\t%d\n", rp->r_fnum);
  916. #endif                    /* DeBugLinker */
  917.  
  918.             outop(rp->r_fnum);
  919.  
  920.             rp = rp->r_link;
  921.             }
  922.          else {
  923.  
  924. #ifdef DeBugLinker
  925.             if (Dflag)
  926.         fprintf(dbgfile, "\t-1\n");
  927. #endif                    /* DeBugLinker */
  928.  
  929.             outop(-1);
  930.             }
  931.  
  932. #ifdef DeBugLinker
  933.          if (Dflag && (i == nrecords || (i & 03) == 0))
  934.             putc('\n', dbgfile);
  935. #endif                    /* DeBugLinker */
  936.  
  937.          }
  938.       }
  939.  
  940.    /*
  941.     * Output descriptors for field names.
  942.     */
  943.  
  944.     hdr.Fnames = pc;
  945.     for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) {
  946.        s = &lsspace[fp->f_name];
  947.  
  948. #ifdef DeBugLinker
  949.        if (Dflag)
  950.           fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n",
  951.                (long)pc, (int)strlen(s), (long)fp->f_name, s);
  952. #endif                    /* DeBugLinker */
  953.  
  954.        outword(strlen(s));      /* name of field: length & offset */
  955.        outword(fp->f_name);
  956.      }
  957.  
  958.  
  959.    /*
  960.     * Output global variable descriptors.
  961.     */
  962.    hdr.Globals = pc;
  963.    for (gp = lgfirst; gp != NULL; gp = gp->g_next) {
  964.       if (gp->g_flag & (F_Builtin & ~F_Global)) {    /* function */
  965.  
  966. #ifdef DeBugLinker
  967.          if (Dflag)
  968.             fprintf(dbgfile, "%ld:\t%06lo\t%d\t\t\t# %s\n",
  969.         (long)pc, (long)D_Proc, -gp->g_procid, &lsspace[gp->g_name]);
  970. #endif                    /* DeBugLinker */
  971.  
  972.          outword(D_Proc);
  973.          outword(-gp->g_procid);
  974.          }
  975.       else if (gp->g_flag & (F_Proc & ~F_Global)) {    /* Icon procedure */
  976.  
  977. #ifdef DeBugLinker
  978.          if (Dflag)
  979.             fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n",
  980.         (long)pc,(long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]);
  981. #endif                    /* DeBugLinker */
  982.  
  983.          outword(D_Proc);
  984.          outword(gp->g_pc);
  985.          }
  986.       else if (gp->g_flag & (F_Record & ~F_Global)) {    /* record constructor */
  987.  
  988. #ifdef DeBugLinker
  989.          if (Dflag)
  990.             fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n",
  991.         (long)pc, (long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]);
  992. #endif                    /* DeBugLinker */
  993.  
  994.          outword(D_Proc);
  995.          outword(gp->g_pc);
  996.          }
  997.       else {    /* global variable */
  998.  
  999. #ifdef DeBugLinker
  1000.          if (Dflag)
  1001.             fprintf(dbgfile, "%ld:\t%06lo\t0\t\t\t# %s\n",(long)pc,
  1002.                (long)D_Null, &lsspace[gp->g_name]);
  1003. #endif                    /* DeBugLinker */
  1004.  
  1005.          outword(D_Null);
  1006.          outword(0);
  1007.          }
  1008.       }
  1009.  
  1010.    /*
  1011.     * Output descriptors for global variable names.
  1012.     */
  1013.    hdr.Gnames = pc;
  1014.    for (gp = lgfirst; gp != NULL; gp = gp->g_next) {
  1015.  
  1016. #ifdef DeBugLinker
  1017.       if (Dflag)
  1018.          fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n",
  1019.             (long)pc, (int)strlen(&lsspace[gp->g_name]), (long)(gp->g_name),
  1020.                &lsspace[gp->g_name]);
  1021. #endif                    /* DeBugLinker */
  1022.  
  1023.       outword(strlen(&lsspace[gp->g_name]));
  1024.       outword(gp->g_name);
  1025.       }
  1026.  
  1027.    /*
  1028.     * Output a null descriptor for each static variable.
  1029.     */
  1030.    hdr.Statics = pc;
  1031.    for (i = lstatics; i > 0; i--) {
  1032.  
  1033. #ifdef DeBugLinker
  1034.       if (Dflag)
  1035.          fprintf(dbgfile, "%ld:\t0\t0\n", (long)pc);
  1036. #endif                    /* DeBugLinker */
  1037.  
  1038.       outword(D_Null);
  1039.       outword(0);
  1040.       }
  1041.    flushcode();
  1042.  
  1043.    /*
  1044.     * Output the string constant table and the two tables associating icode
  1045.     *  locations with source program locations.  Note that the calls to write
  1046.     *  really do all the work.
  1047.     */
  1048.  
  1049.  
  1050.    hdr.Filenms = pc;
  1051.    if (longwrite((char *)fnmtbl, (long)((char *)fnmfree - (char *)fnmtbl),
  1052.       outfile) < 0)
  1053.          quit("cannot write icode file");
  1054.  
  1055. #ifdef DeBugLinker
  1056.    if (Dflag) {
  1057.       int k = 0;
  1058.       struct ipc_fname *ptr;
  1059.       for (ptr = fnmtbl; ptr < fnmfree; ptr++) {
  1060.          fprintf(dbgfile, "%ld:\t%03d\tS+%03d\n", (long)(pc + k), ptr->ipc,
  1061.             ptr->fname);
  1062.          k = k + 8;
  1063.          }
  1064.       putc('\n', dbgfile);
  1065.       }
  1066.  
  1067. #endif                    /* DeBugLinker */
  1068.  
  1069.    pc += (char *)fnmfree - (char *)fnmtbl;
  1070.  
  1071.    hdr.linenums = pc;
  1072.    if (longwrite((char *)lntable, (long)((char *)lnfree - (char *)lntable),
  1073.       outfile) < 0)
  1074.          quit("cannot write icode file");
  1075.  
  1076. #ifdef DeBugLinker
  1077.    if (Dflag) {
  1078.       int k = 0;
  1079.       struct ipc_line *ptr;
  1080.       for (ptr = lntable; ptr < lnfree; ptr++) {
  1081.          fprintf(dbgfile, "%ld:\t%03d\t%03d\n", (long)(pc + k),
  1082.             ptr->ipc, ptr->line);
  1083.          k = k + 8;
  1084.          }
  1085.       putc('\n', dbgfile);
  1086.       }
  1087.  
  1088. #endif                    /* DeBugLinker */
  1089.  
  1090.    pc += (char *)lnfree - (char *)lntable;
  1091.  
  1092.    hdr.Strcons = pc;
  1093. #ifdef DeBugLinker
  1094.    if (Dflag) {
  1095.       int k = 0;
  1096.       for (s = lsspace; s < &lsspace[lsfree]; ) {
  1097.          fprintf(dbgfile, "%ld:\t%03o", (long)(pc + k), *s++);
  1098.          k = k + 8;
  1099.          for (i = 7; i > 0; i--) {
  1100.             if (s >= &lsspace[lsfree])
  1101.         break;
  1102.             fprintf(dbgfile, " %03o", *s++);
  1103.             }
  1104.          putc('\n', dbgfile);
  1105.          }
  1106.       }
  1107.  
  1108. #endif                    /* DeBugLinker */
  1109.  
  1110.  
  1111.    if (longwrite(lsspace, (long)lsfree, outfile) < 0)
  1112.          quit("cannot write icode file");
  1113.  
  1114.    pc += lsfree;
  1115.  
  1116.    /*
  1117.     * Output icode file header.
  1118.     */
  1119.    hdr.hsize = pc;
  1120.    strcpy((char *)hdr.config,IVersion);
  1121.    hdr.trace = trace;
  1122.  
  1123. #ifdef Xver
  1124. xver(lcode.5)
  1125. #endif                    /* Xver */
  1126.  
  1127. #ifdef DeBugLinker
  1128.    if (Dflag) {
  1129.       fprintf(dbgfile, "size:     %ld\n", (long)hdr.hsize);
  1130.       fprintf(dbgfile, "trace:     %ld\n", (long)hdr.trace);
  1131.       fprintf(dbgfile, "records: %ld\n", (long)hdr.Records);
  1132.       fprintf(dbgfile, "ftab:     %ld\n", (long)hdr.Ftab);
  1133.       fprintf(dbgfile, "fnames:  %ld\n", (long)hdr.Fnames);
  1134.       fprintf(dbgfile, "globals: %ld\n", (long)hdr.Globals);
  1135.       fprintf(dbgfile, "gnames:  %ld\n", (long)hdr.Gnames);
  1136.       fprintf(dbgfile, "statics: %ld\n", (long)hdr.Statics);
  1137.       fprintf(dbgfile, "strcons:   %ld\n", (long)hdr.Strcons);
  1138.       fprintf(dbgfile, "filenms:   %ld\n", (long)hdr.Filenms);
  1139.       fprintf(dbgfile, "linenums:   %ld\n", (long)hdr.linenums);
  1140.       fprintf(dbgfile, "config:   %s\n", hdr.config);
  1141.       }
  1142. #endif                    /* DeBugLinker */
  1143.  
  1144. #ifdef Header
  1145.    fseek(outfile, (long)MaxHeader, 0);
  1146. #else                                   /* Header */
  1147.  
  1148. #if MVS
  1149. /*
  1150.  * This kind of backpatching cannot work on a PDS member, and that's
  1151.  *  probably where the code is going.  So the code goes out first to
  1152.  *  a temporary file, and then copied to the real icode file after
  1153.  *  the header is written.
  1154.  */
  1155.    fseek(outfile, sizeof(hdr), SEEK_SET);
  1156.    toutfile = outfile;
  1157.    outfile = fopen(routname, WriteBinary);
  1158.    if (outfile == NULL)
  1159.       quitf("cannot create %s",routname);
  1160. #else
  1161.    fseek(outfile, 0L, 0);
  1162. #endif                                  /* MVS */
  1163. #endif                                  /* Header */
  1164.  
  1165.    if (longwrite((char *)&hdr, (long)sizeof(hdr), outfile) < 0)
  1166.       quit("cannot write icode file");
  1167.  
  1168. #if MVS
  1169.    {
  1170.       char *allelse = malloc(hdr.hsize);
  1171.       if (hdr.hsize != fread(allelse, 1, hdr.hsize, toutfile) ||
  1172.           longwrite(allelse, hdr.hsize, outfile) < 0)
  1173.             quit("cannot write icode file");
  1174.       free(allelse);
  1175.       fclose(toutfile);
  1176.    }
  1177. #endif                    /* MVS */
  1178.    }
  1179.  
  1180. /*
  1181.  * intout(i) outputs i as an int that is used by the runtime system
  1182.  *  IntBits/ByteBits bytes must be moved from &word[0] to &codep[0].
  1183.  */
  1184. static novalue intout(oint)
  1185. int oint;
  1186.    {
  1187.    int i;
  1188.    union {
  1189.       int i;
  1190.       char c[IntBits/ByteBits]; 
  1191.       } u;
  1192.  
  1193.    CodeCheck(IntBits/ByteBits);
  1194.    u.i = oint;
  1195.  
  1196.    for (i = 0; i < IntBits/ByteBits; i++)
  1197.       codep[i] = u.c[i];
  1198.  
  1199.    codep += IntBits/ByteBits;
  1200.    pc += IntBits/ByteBits;
  1201.    }
  1202.  
  1203. /*
  1204.  * wordout(i) outputs i as a word that is used by the runtime system
  1205.  *  WordSize bytes must be moved from &oword[0] to &codep[0].
  1206.  */
  1207. static novalue wordout(oword)
  1208. word oword;
  1209.    {
  1210.    int i;
  1211.    union {
  1212.     word i;
  1213.     char c[WordSize];
  1214.     } u;
  1215.  
  1216.    CodeCheck(WordSize);
  1217.    u.i = oword;
  1218.  
  1219.    for (i = 0; i < WordSize; i++)
  1220.       codep[i] = u.c[i];
  1221.  
  1222.    codep += WordSize;
  1223.    pc += WordSize;
  1224.    }
  1225.  
  1226. /*
  1227.  * outblock(a,i) output i bytes starting at address a.
  1228.  */
  1229. static novalue outblock(addr,count)
  1230. char *addr;
  1231. int count;
  1232.    {
  1233.    CodeCheck(count);
  1234.    pc += count;
  1235.    while (count--)
  1236.       *codep++ = *addr++;
  1237.    }
  1238.  
  1239. #ifdef DeBugLinker
  1240. /*
  1241.  * dumpblock(a,i) dump contents of i bytes at address a, used only
  1242.  *  in conjunction with -L.
  1243.  */
  1244. static novalue dumpblock(addr, count)
  1245. char *addr;
  1246. int count;
  1247.    {
  1248.    int i;
  1249.    for (i = 0; i < count; i++) {
  1250.       if ((i & 7) == 0)
  1251.          fprintf(dbgfile,"\n\t");
  1252.       fprintf(dbgfile," %03o",(0377 & (unsigned)addr[i]));
  1253.       }
  1254.    putc('\n',dbgfile);
  1255.    }
  1256. #endif                    /* DeBugLinker */
  1257.  
  1258. /*
  1259.  * flushcode - write buffered code to the output file.
  1260.  */
  1261. static novalue flushcode()
  1262.    {
  1263.    if (codep > codeb)
  1264.       if (longwrite(codeb, DiffPtrs(codep,codeb), outfile) < 0)
  1265.          quit("cannot write icode file");
  1266.    codep = codeb;
  1267.    }
  1268.  
  1269. /*
  1270.  * clearlab - clear label table to all zeroes.
  1271.  */
  1272. static novalue clearlab()
  1273.    {
  1274.    register int i;
  1275.  
  1276.    for (i = 0; i < maxlabels; i++)
  1277.       labels[i] = 0;
  1278.    }
  1279.  
  1280. /*
  1281.  * backpatch - fill in all forward references to lab.
  1282.  */
  1283. static novalue backpatch(lab)
  1284. int lab;
  1285.    {
  1286.    word p, r;
  1287.    char *q;
  1288.    char *cp, *cr;
  1289.    register int j;
  1290.  
  1291.    if (lab >= maxlabels)
  1292.       labels  = (word *) trealloc(labels, NULL, &maxlabels, sizeof(word),
  1293.          lab - maxlabels + 1, "labels");
  1294.  
  1295.    p = labels[lab];
  1296.    if (p > 0)
  1297.       quit("multiply defined label in ucode");
  1298.    while (p < 0) {        /* follow reference chain */
  1299.  
  1300. #ifdef CRAY
  1301.       r = (pc - (WordSize - p))/8;    /* compute relative offset */
  1302. #else                    /* CRAY */
  1303.       r = pc - (WordSize - p);    /* compute relative offset */
  1304. #endif                    /* CRAY */
  1305.       q = codep - (pc + p);    /* point to word with address */
  1306.       cp = (char *) &p;        /* address of integer p       */
  1307.       cr = (char *) &r;        /* address of integer r       */
  1308.       for (j = 0; j < WordSize; j++) {      /* move bytes from word pointed to */
  1309.          *cp++ = *q;              /* by q to p, and move bytes from */
  1310.          *q++ = *cr++;              /* r to word pointed to by q */
  1311.          }            /* moves integers at arbitrary addresses */
  1312.       }
  1313.    labels[lab] = pc;
  1314.    }
  1315.  
  1316. #ifdef DeBugLinker
  1317. novalue idump(s)        /* dump code region */
  1318.    char *s;
  1319.    {
  1320.    int *c;
  1321.  
  1322.    fprintf(stderr,"\ndump of code region %s:\n",s);
  1323.    for (c = (int *)codeb; c < (int *)codep; c++)
  1324.        fprintf(stderr,"%ld: %d\n",(long)c, (int)*c);
  1325.    fflush(stderr);
  1326.    }
  1327. #endif                    /* DeBugLinker */
  1328.